Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/himetr1r/moddata.bas

BASIC Source File | 1999-08-18 | 48.5 KB | 1,771 lines

Attribute VB_Name = "modData"
'----------------------------------------
'- Name: Sam Huggill
'- Email: [e-mail]
'- Web: http://www.vbsquare.com/
'- Company: Lighthouse Internet Solutions
'- Date/Time: 14/08/99 11:30:46
'----------------------------------------
'- Notes:   An interface between the project
'           and the database
'----------------------------------------

Option Explicit

' Private Members of the form
Private m_strCode As String     '// Code
Private m_strNotes As String    '// Notes
Private m_strExample As String  '// Example
Private m_strDesc As String     '// Description
Private m_strKey As String      '// Item ID
Private m_strParentKey As String '// Parent ID
Private m_strDate As String     '// Date of file
Public m_strDBName As String   '// DB Name

Private m_db As Database        '// Database
Private m_rs As Recordset       '// Recordset
Private m_nodNode As Node       '// Current Node
Private m_liItem As ListItem    '// Current List Item

' Public Members
Public g_strVersion As String   '// Version
Public g_strLevel As String     '// Level
Public g_blnRTF As Boolean      '// Include RTF Colouring

Private Const CHUNKSIZE As Long = 16384 ' internal chunksize

Public Sub FillTree(tvw As TreeView)

    Dim blnFolder As Boolean

    On Error GoTo vbErrHand

' Fill tvw with the records in the database

    With tvw.Nodes
        .Clear
        .Add , , "ROOT", "Developers Code Book", "ROOT"
    End With

' If the database is only version 2, then don't try to add
' any folders

    If GetVersion = 2 Then GoTo FillCode

    Set m_rs = m_db.OpenRecordset("SELECT * FROM Folders Order By ParentID", dbOpenSnapshot)

    If EmptyRS(m_rs) Then
        GoTo FillCode
    End If

' Add the folders to the treeview

    m_rs.MoveFirst
    With tvw.Nodes

        Do While Not m_rs.EOF
            m_strParentKey = m_rs!ParentID
            m_strKey = m_rs!Id
            m_strDesc = "" & m_rs!Name
            Set m_nodNode = tvw.Nodes.Add("ROOT", tvwChild, "F" & m_strKey, m_strDesc, "CLOSED")
            m_nodNode.Tag = "F" & m_strParentKey
            m_rs.MoveNext
        Loop
    End With

    m_rs.Close

FillCode:

' Add the code items to the tree

    Set m_rs = m_db.OpenRecordset("SELECT * FROM Code Order By ParentID", dbOpenSnapshot)

    If EmptyRS(m_rs) Then
        If tvw.Nodes("ROOT") Is Nothing Then
            tvw.Nodes.Add , , "ROOT", "Developers Code Book", "ROOT"
            HighlightFolders tvw, "ROOT"
        End If
        GoTo CleanUp
    End If

    m_rs.MoveFirst

' Start adding the code items

    With tvw.Nodes

        Do While Not m_rs.EOF

            m_strParentKey = m_rs!ParentID
            m_strKey = "" & m_rs!Id
            m_strDesc = "" & m_rs!Description

            Set m_nodNode = tvw.Nodes.Add("ROOT", tvwChild, "C" & m_strKey, m_strDesc, "MODULE")
            If GetVersion = 3 Then
                m_nodNode.Tag = "F" & m_strParentKey
            Else
                m_nodNode.Tag = "C" & m_strParentKey
            End If

            m_rs.MoveNext

        Loop

    End With

' Now rebuild the tree structure based on the ParentID

    For Each m_nodNode In tvw.Nodes
        m_strParentKey = m_nodNode.Tag

        If Len(m_strParentKey) > 0 Then
' Don't bother check which version here, just account for both
            If m_strParentKey = "F0" Or m_strParentKey = "C0" Then
                m_strParentKey = "ROOT"
            End If
            Set m_nodNode.Parent = tvw.Nodes(m_strParentKey)
        End If
    Next

CleanUp:

' Make the first level folders visilbe

    tvw.Nodes("ROOT").Expanded = True
    tvw.Nodes("ROOT").Sorted = True
    HighlightFolders tvw, "ROOT"
    m_rs.Close

' Go through the folders and sort them
' If Version 2, then set the appropriate icon

    For Each m_nodNode In tvw.Nodes
        If Not m_nodNode.Key = "ROOT" Then
            If m_nodNode.Children > 0 Then
                m_nodNode.Sorted = True
                If GetVersion = 2 Then
                    m_nodNode.Image = "CLOSED"
                End If
            End If
        End If
    Next

    Exit Sub

vbErrHand:
    WriteError Err.Number, Err.Description, "FillTree", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "FillTree"

End Sub

Private Function EmptyRS(rs As Recordset) As Boolean

' Returns True if rs is empty

    EmptyRS = ((rs.BOF = True) And (rs.EOF = True))

End Function

Public Function OpenDB(ByVal strDBPath As String) As Boolean

    On Error GoTo vbErrHand

' Returns True if successful

' Check whether or not a filename has been passed
' If not, ask the user to open a new database

    If strDBPath = "" Then
        strDBPath = frmMain.ShowFileDialog(eOpen, "", "Open Database")
        If strDBPath = "" Then MsgBox "No DB Selected. Ending program.": OpenDB = False: Unload frmMain
    End If

' Open the DB and Set the m_db variable

    Set m_db = OpenDatabase(strDBPath)
    m_strDBName = strDBPath
    OpenDB = True

    Exit Function

vbErrHand:
    WriteError Err.Number, Err.Description, "OpenDB", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "OpenDB"
    Resume Next
End Function

Public Function SelectItem(ByVal strKey As String, ctl As Object) As String

    On Error GoTo vbErrHand

    Dim intKey As Integer
    Dim blnFolder As Boolean

' Select the appropriate data for an item

    If strKey = "ROOT" Then ctl.Code = "": ctl.Notes = "": ctl.Example = "": ctl.Caption = "Developers Code Book"

' Check if the item is a folder object

    blnFolder = InStr(strKey, "F")

    If strKey <> "ROOT" Then

        intKey = Right(strKey, Len(strKey) - 1)

' Open the correct table according the whether or not the item is a folder

        If blnFolder Then
            Set m_rs = m_db.OpenRecordset("SELECT * FROM Folders WHERE ID =" & intKey, dbOpenDynaset)
        Else
            Set m_rs = m_db.OpenRecordset("SELECT * FROM Code WHERE ID =" & intKey, dbOpenDynaset)
        End If

        If Not EmptyRS(m_rs) Then
            If blnFolder Then

                With m_rs
                    m_strCode = ""
                    m_strExample = ""
                    m_strNotes = ""
                    m_strDesc = "" & .Fields("Name").Value
                    g_strLevel = ""
                    g_strVersion = ""
                    .Close
                End With

                ctl.Code = m_strCode
                ctl.Example = m_strExample
                ctl.Notes = m_strNotes
                ctl.Caption = m_strDesc
            Else

                With m_rs
                    m_strCode = "" & .Fields("Code").Value
                    m_strExample = "" & .Fields("Example").Value
                    m_strDesc = "" & .Fields("Description").Value
                    m_strNotes = "" & .Fields("Notes").Value
                    g_strLevel = "" & .Fields("Level").Value
                    g_strVersion = "" & .Fields("Version").Value
                    .Close
                End With

                ctl.Code = m_strCode
                ctl.Example = m_strExample
                ctl.Notes = m_strNotes
                ctl.Caption = m_strDesc
            End If

        End If
    End If

' Return the name of the item

    SelectItem = m_strDesc
    frmMain.Caption = "Developers Code Book: " & m_strDesc

    If GetVersion = 3 Then frmMain.tbrMain.ButtonEnabled("NEW") = InStr(strKey, "F")

    If frmMain.tbrMain.ButtonEnabled("NEW") = False And strKey = "ROOT" Then frmMain.tbrMain.ButtonEnabled("NEW") = True
    ctl.Details True

    If InStr(strKey, "F") Then ctl.Details False


    Exit Function

vbErrHand:
    WriteError Err.Number, Err.Description, "SelectItem", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "SelectItem"

End Function

Sub BackupDatabase(sDBPath As String, sOutput As String)

    On Error GoTo vbErrHand

' If the backup file exists, then delete it

    If Len(Dir$(sOutput)) > 0 Then
        Kill sOutput
    End If

' Compact the db to the new path

    DBEngine.CompactDatabase sDBPath, sOutput

    Exit Sub

vbErrHand:
    WriteError Err.Number, Err.Description, "BackupDatabase", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "BackupDatabase"

End Sub

Sub CompactDatabase(sDBName As String, sBackup As String)

    On Error GoTo vbErrHand

' Check if the temp file exists and delete it

    If Len(Dir$(sBackup)) > 0 Then
        Kill sBackup
    End If

' Compact the database to a temp file

    DBEngine.CompactDatabase sDBName, sBackup

' Delete the current database

    Kill sDBName

' Restore the compacted temp database to the current one

    DBEngine.CompactDatabase sBackup, sDBName

' Delete the temp database

    Kill sBackup

    Exit Sub

vbErrHand:
    WriteError Err.Number, Err.Description, "CompactDatabase", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "CompactDatabase"

End Sub

Sub RepairDatabase(sDBName As String)

    On Error GoTo vbErrHand

' Repair the database

    DBEngine.RepairDatabase sDBName

    Exit Sub

vbErrHand:
    WriteError Err.Number, Err.Description, "RepairDatabase", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "RepairDatabase"

End Sub

Public Sub UpdateDB(tvw As TreeView)

    On Error GoTo vbErrHand

    Dim intID As Integer
    Dim blnFolder As Boolean

' Update the database values for the name
' Useful when label edits take place in the tvw

    Set m_nodNode = tvw.SelectedItem
    If m_nodNode.Key = "ROOT" Then Exit Sub

' Set the internal key and get the ID value

    m_strKey = m_nodNode.Key
    intID = Right$(m_strKey, Len(m_strKey) - 1)

' Check if the item is a folder, and open the correct table

    blnFolder = InStr(m_strKey, "F")

    If blnFolder Then
        Set m_rs = m_db.OpenRecordset("SELECT * FROM Folders WHERE ID =" & intID, dbOpenDynaset)
    Else
        Set m_rs = m_db.OpenRecordset("SELECT * FROM Code WHERE ID =" & intID, dbOpenDynaset)
    End If

' Update the table

    If blnFolder Then
        With m_rs
            .Edit
            .Fields("Name").Value = m_strDesc
            .Update
            .Close
        End With
    Else

        With m_rs
            .Edit
            .Fields("Description").Value = m_strDesc
            .Fields("Code").AppendChunk m_strCode
            .Fields("Example").AppendChunk m_strExample
            .Fields("Notes").AppendChunk m_strNotes

            If g_strVersion <> "" Then
                .Fields("Version").Value = g_strVersion
            End If

            If g_strLevel <> "" Then
                .Fields("Level").Value = g_strLevel
            End If

            .Update
            .Close
        End With
    End If

    Exit Sub

vbErrHand:
    WriteError Err.Number, Err.Description, "UpdateDB", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "UpdateDB"
End Sub

Public Property Let Code(ByVal New_Code As String)
    m_strCode = New_Code
End Property

Public Property Let Key(ByVal New_Key As String)
    m_strKey = New_Key
End Property

Public Property Get Key() As String
    Key = m_strKey
End Property

Public Property Let Notes(ByVal New_Notes As String)
    m_strNotes = New_Notes
End Property

Public Property Let Example(ByVal New_Example As String)
    m_strExample = New_Example
End Property

Public Property Let Description(ByVal New_Description As String)
    m_strDesc = New_Description
End Property

Public Property Get Description() As String
    Description = m_strDesc
End Property

Public Sub LoadBookmarks(lv As ListView)

    On Error GoTo vbErrHand

    Dim blnFolder As Boolean
    lv.ListItems.Clear

' Load the bookmarks into the listview

    Set m_rs = m_db.OpenRecordset("SELECT * FROM Bookmarks", dbOpenDynaset)

    If Not EmptyRS(m_rs) Then
        m_rs.MoveFirst

' If the item is a folder then make sure its key is prefixed
' by an F

        Do While Not m_rs.EOF
        If GetVersion = 3 Then
            blnFolder = m_rs!IsFolder
        Else
            blnFolder = False
        End If

            m_strKey = Trim$(Str(m_rs!CodeID))
            Set m_liItem = lv.ListItems.Add(, , m_rs!Description)

            If blnFolder Then
                m_liItem.Key = "F" & m_strKey
            Else
                m_liItem.Key = "C" & m_strKey
            End If

            m_liItem.SubItems(1) = "" & m_rs!Section

            m_rs.MoveNext
        Loop
    End If
    m_rs.Close

    Exit Sub

vbErrHand:
    WriteError Err.Number, Err.Description, "LoadBookmarks", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "LoadBookmarks"
End Sub

Public Function SortBy(strType As String, strValue As String, lv As ListView) As String

    On Error GoTo vbErrHand

' Load the Sort information

    lv.ListItems.Clear

    Set m_rs = m_db.OpenRecordset("SELECT * FROM Code", dbOpenSnapshot)

    If Not EmptyRS(m_rs) Then
        m_rs.MoveFirst
        Do While Not m_rs.EOF

            If strType = "Version" Then

                If m_rs!Version = strValue Then

                    Set m_liItem = lv.ListItems.Add(, , m_rs!Description)
                    m_liItem.Key = "C" & m_rs!Id

                End If

            End If

            If strType = "Level" Then

                If m_rs!Level = strValue Then

                    Set m_liItem = lv.ListItems.Add(, , m_rs!Description)
                    m_liItem.Key = "C" & m_rs!Id

                End If

            End If

            m_rs.MoveNext
        Loop
    End If

    m_rs.Close

    If strType = "Version" Then
        SortBy = "Sort by Version: " & strValue
    End If

    If strType = "Level" Then
        SortBy = "Sort by Level: " & strValue
    End If

    Exit Function

vbErrHand:
    WriteError Err.Number, Err.Description, "SortBy", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "SortBy"
End Function


Public Sub RecursiveExportCode(nNode As Node, ByVal iFileNumber As Integer, ctl As Object)

    Dim nNodeChild As Node
    Dim intIndex As Integer
    Dim blnFolder As Boolean
    Dim strKey As String
    Dim oExport As FileDetails

' Recursively Export Node Items by Chris Eastwood

    strKey = nNode.Key

    On Error Resume Next

    On Error GoTo 0
    '// Get Details for item (as long as it's not the Root Item)
    If StrComp(strKey, "ROOT", vbTextCompare) <> 0 Then
        blnFolder = InStr(strKey, "F")
        strKey = Right$(strKey, Len(strKey) - 1)
        If blnFolder Then
            Set m_rs = m_db.OpenRecordset("SELECT * FROM Folders WHERE ID =" & strKey, dbOpenSnapshot)
        Else
            Set m_rs = m_db.OpenRecordset("SELECT * FROM Code WHERE ID =" & strKey, dbOpenSnapshot)
        End If
        oExport.sOldID = m_rs!Id
        oExport.bFolder = blnFolder
        oExport.sParentID = m_rs!ParentID
        If blnFolder Then
            oExport.sName = m_rs!Name
        Else
            oExport.sName = m_rs!Description
            oExport.sNotes = "" & m_rs!Notes
            oExport.sLevel = "" & m_rs!Level
            oExport.sVersion = "" & m_rs!Version
            frmMain.ctlData1.Code = "" & m_rs!Code
            If g_blnRTF Then
                oExport.sCode = ctl.Code
            Else
                oExport.sCode = ctl.PlainCode
            End If
            oExport.sExample = "" & m_rs!Example
        End If
        oExport.sParentName = nNode.Parent.Key

        Put #iFileNumber, , oExport

    End If

    '    m_rs.Close

    Set nNodeChild = nNode.Child
    '// Now walk through the current parent node's children
    Do While Not (nNodeChild Is Nothing)
        '// If the current child node has it's own children...
        RecursiveExportCode nNodeChild, iFileNumber, ctl
        '// Get the current child node's next sibling
        Set nNodeChild = nNodeChild.Next
    Loop
End Sub

Private Sub RecursiveDelete(oNode As Node, tvw As TreeView)
    Dim nNodeChild As Node
    Dim intID As Integer
    Dim blnFolder As Boolean

    On Error GoTo vbErrHand
    '// Recursivly delete nodes By Chris Eastwood
    '// Get the items ID
    intID = Right(m_strKey, Len(m_strKey) - 1)
    blnFolder = InStr(m_strKey, "F")
    '// Open the RS
    If blnFolder Then
        Set m_rs = m_db.OpenRecordset("SELECT * FROM Folders WHERE ID =" & intID, dbOpenDynaset)
    Else
        Set m_rs = m_db.OpenRecordset("SELECT * FROM Code WHERE ID = " & intID, dbOpenDynaset)
    End If

    With m_rs
        .Delete
        .Close
    End With
    '// Delete the nodes children
    Set nNodeChild = oNode.Child
    Do While Not (nNodeChild Is Nothing)
        m_strKey = nNodeChild.Key
        intID = Right(m_strKey, Len(m_strKey) - 1)
        RecursiveDelete nNodeChild, tvw
        Set nNodeChild = nNodeChild.Next
    Loop

    Exit Sub

vbErrHand:
    WriteError Err.Number, Err.Description, "RecursiveDelete", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "RecursiveDelete"

End Sub

Public Sub DoActions()

    Dim blnBackup As Boolean
    Dim blnCompact As Boolean
    Dim blnRepair As Boolean
    '// Compact, repair and backup
    If Not (m_db Is Nothing) Then
        m_db.Close
        Set m_db = Nothing
    End If

    blnBackup = Val(GetSetting(ThisApp, "Database", "Backup", 0))
    blnCompact = Val(GetSetting(ThisApp, "Database", "Compact", 0))
    blnRepair = Val(GetSetting(ThisApp, "Database", "Repair", 0))

    If blnBackup Then Call BackupDatabase(DBName, App.Path & "\backup.mdb")
    DoEvents
    If blnCompact Then Call CompactDatabase(DBName, App.Path & "\temp.mdb")
    DoEvents
    If blnRepair Then Call RepairDatabase(DBName)

    OpenDB DBName

End Sub

Public Sub ShowDetails(tvw As TreeView, lv As ListView)

    On Error GoTo vbErrHand

    '// Load a folders details into lv
    Dim intID As Integer
    Dim mID As Integer
    Dim mrs As Recordset

    On Error Resume Next

    lv.ListItems.Clear

    If tvw.Nodes(m_strKey).Children > 0 Then '// Item has children
        '// Get the items ID
        intID = Val(Right$(m_strKey, Len(m_strKey) - 1))
        '// Open the RS
        Set m_rs = m_db.OpenRecordset("SELECT * FROM Code Order By ParentID", dbOpenSnapshot)
        If Not EmptyRS(m_rs) Then
            m_rs.MoveFirst
            Do While Not m_rs.EOF
                If m_rs!ParentID = intID Then '// Is a child of our item
                    Set m_liItem = lv.ListItems.Add(, , m_rs!Description)
                    m_liItem.Key = "C" & m_rs!Id
                    mID = m_rs!Id
                    Set mrs = m_db.OpenRecordset("SELECT * FROM Links WHERE CodeID =" & mID, dbOpenDynaset)
                    '// Linkname still to be finished!
                    m_liItem.SubItems(1) = mrs!LinkName
                    '// Created still to be finsihed!
                    m_liItem.SubItems(2) = mrs!Created
                    mrs.Close
                End If
                m_rs.MoveNext
            Loop
        End If
        m_rs.Close
    Else
        '// Item has no children
    End If

    Exit Sub

vbErrHand:
    WriteError Err.Number, Err.Description, "ShowDetails", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "ShowDetails"
End Sub

Public Sub SetNothing()
    '// Free up memory on unload
    If Not (m_rs Is Nothing) Then
        Set m_rs = Nothing
    End If

    If Not (m_db Is Nothing) Then
        m_db.Close
        Set m_db = Nothing
    End If

    Set m_liItem = Nothing
    Set m_nodNode = Nothing
End Sub

Public Sub CompareCode(tvw As TreeView, strCode As String, strField As String)
    Dim intID As Integer
    '// Makes a judgement whether to update code or not
    If tvw.SelectedItem Is Nothing Then Exit Sub

    m_strKey = tvw.SelectedItem.Key
    If m_strKey = "ROOT" Then Exit Sub
    '// Get the items ID
    intID = Right(m_strKey, Len(m_strKey) - 1)
    '// Open the RS
    Set m_rs = m_db.OpenRecordset("SELECT * FROM Code WHERE ID =" & intID, dbOpenDynaset)

    If m_rs.Fields(strField).Value & "" <> strCode Then
        Select Case strField
            Case "Code"
                m_strCode = strCode
            Case "Notes"
                m_strNotes = strCode
            Case "Example"
                m_strExample = strCode
            Case Else
        End Select
        UpdateDB tvw
    End If

    '    m_rs.Close
End Sub

Public Sub DeleteFavourite(lv As ListView, strKey As String)
    Dim intIndex As Integer
    Dim intCount As Integer
    Dim intID As Integer
    '// Deletes a favourite from the db and lv
    For intCount = 1 To lv.ListItems.Count
        If lv.ListItems(intCount).Key = strKey Then
            intIndex = intCount
            Exit For
        End If
    Next intCount
    '// Get the items ID
    intID = Right(strKey, Len(strKey) - 1)

    If intIndex > 0 Then
        '// Open the RS
        Set m_rs = m_db.OpenRecordset("SELECT * FROM Bookmarks WHERE CodeID = " & Str$(intID), dbOpenDynaset)
        If Not EmptyRS(m_rs) Then
            With m_rs
                '// Delete the item
                .Delete
                .Close
            End With
        End If
        '// Remove it from the lv
        lv.ListItems.Remove intIndex
    End If

End Sub

Public Function AddCode(tvw As TreeView, sName As String, sNotes As String, strVer As String, strLevel As String, blnSame As Boolean) As Boolean
    Dim sParentKey As String
    Dim intID As Integer
    Dim sTitle As String
    '// Adds a code item to the tree and the db
    AddCode = False

    On Error GoTo vbErrHand

    If sName = "" Then MsgBox "Please enter a title.": Exit Function
    '// Determines whether or not to add the item
    '// at the same level or below it
    If blnSame Then
        Set m_nodNode = tvw.SelectedItem.Parent
    Else
        Set m_nodNode = tvw.SelectedItem
    End If
    '// Should not happen but check anyway
    If m_nodNode Is Nothing Then
        MsgBox "No item selected.", vbOKOnly + vbInformation
        AddCode = False
        AddCode = True
        Exit Function
    End If

    If m_nodNode.Key = "ROOT" Then
        sParentKey = "0"
    Else
        sParentKey = Right$(m_nodNode.Key, Len(m_nodNode.Key) - 1)
    End If
    '// Open the RS
    Set m_rs = m_db.OpenRecordset("SELECT * FROM Code Where ID = 0", dbOpenDynaset)

    sTitle = sName

    '// Add and update the necessary fields
    With m_rs
        .AddNew
        .Fields("Description").Value = sTitle
        .Fields("ParentID").Value = sParentKey '// nNode.Index
        .Fields("Code").AppendChunk m_strCode
        .Fields("Notes").AppendChunk sNotes
        .Fields("Version").Value = strVer
        .Fields("Level").Value = strLevel
        .Update
        .Bookmark = .LastModified
        intID = .Fields("ID")
        .Close
    End With

    If blnSame Then
        Set m_nodNode = tvw.Nodes.Add(tvw.SelectedItem.Parent, tvwChild, "C" & intID, sTitle, "MODULE")
    Else
        Set m_nodNode = tvw.Nodes.Add(tvw.SelectedItem, tvwChild, "C" & intID, sTitle, "MODULE")
    End If

    With tvw
        .Nodes(m_nodNode.Key).EnsureVisible
        .SelectedItem = .Nodes(m_nodNode.Key)
    End With
    '// Select the new item
    SelectItem m_nodNode.Key, frmMain.ctlData1

    AddCode = True

    frmMain.ctlData1.CountItems tvw

    Exit Function

vbErrHand:
    WriteError Err.Number, Err.Description, "AddCode", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "AddCode"

End Function

Public Sub DeleteNode(tvw As TreeView)
    '// Deletes an item from tvw and the db
    Dim ret As Long
    Dim Msg As String
    Dim blnFolder As Boolean

    On Error GoTo vbErrHand

    '// Set the node handler and check if it is the root
    Set m_nodNode = tvw.SelectedItem
    If m_nodNode Is Nothing Then
        MsgBox "No item selected.", vbOKOnly + vbInformation
        Exit Sub
    End If

    m_strKey = m_nodNode.Key
    If m_strKey = "ROOT" Then Exit Sub
    blnFolder = InStr(m_strKey, "F")
    '// Check for any children and tell the user
    If m_nodNode.Children > 0 Then
        Msg = "Are you sure you want to delete this folder and all its children?"
    Else
        Msg = "Are you sure you want to delete this item?"
    End If

    ret = MsgBox(Msg, vbExclamation + vbYesNo)
    If ret = vbNo Then Exit Sub

    '// Recursivly delete the nodes children and update the
    '// bookmarks control

    RecursiveDelete m_nodNode, tvw
    m_strKey = tvw.SelectedItem.Key

    frmMain.ctlFavourites1.DeleteItem tvw
    tvw.Nodes.Remove m_strKey

    frmMain.ctlData1.Code = ""
    frmMain.ctlData1.Caption = ""
    frmMain.ctlData1.Notes = ""
    frmMain.ctlData1.Example = ""
    frmMain.ctlData1.CountItems tvw

    If tvw.SelectedItem.Children = 0 And tvw.SelectedItem.Image = "OPEN" Then tvw.SelectedItem.Image = "MODULE"
    '// Select the item
    SelectItem tvw.SelectedItem.Key, frmMain.ctlData1

    Exit Sub

vbErrHand:
    WriteError Err.Number, Err.Description, "DeleteNode", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "DeleteNode"


End Sub

Public Sub AddFavourite(tvw As TreeView, lv As ListView)
    Dim intIndex As Integer
    Dim intID As Integer
    Dim blnFolder As Boolean

    '// Adds a favourite to lv and the db
    If m_strKey = "ROOT" Then
        MsgBox "Cannot make the root item a favourite."
        Exit Sub
    End If

    m_strKey = tvw.SelectedItem.Key
    '// Get the items ID
    intID = Right(m_strKey, Len(m_strKey) - 1)
    blnFolder = InStr(m_strKey, "F")
    Set m_nodNode = tvw.Nodes(m_strKey)
    '// Check if the item is in lv
    For intIndex = 1 To lv.ListItems.Count
        If blnFolder Then
            If lv.ListItems(intIndex).Key = "F" & intID Then
                MsgBox "Item already added."
                Exit Sub
            End If
        Else
            If lv.ListItems(intIndex).Key = "C" & intID Then
                MsgBox "Item already added."
                Exit Sub
            End If
        End If
    Next intIndex
    '// Add the item
    With lv

        Set m_liItem = .ListItems.Add(, , m_nodNode.Text)
        m_liItem.Key = m_strKey
        m_liItem.SubItems(1) = m_nodNode.Parent.Text

    End With

    '// Open and update the rs
    Set m_rs = m_db.OpenRecordset("SELECT * FROM Bookmarks", dbOpenDynaset)

    intID = Right$(m_nodNode.Key, Len(m_nodNode.Key) - 1)

    With m_rs
        .AddNew
        .Fields("CodeID").Value = intID
        .Fields("Description").Value = m_nodNode.Text
        .Fields("Section").Value = m_nodNode.Parent.Text
        If GetVersion = 3 Then
            .Fields("IsFolder").Value = blnFolder
        End If
        .Update
        .Close
    End With

End Sub

Public Sub ImportCodeItems(tvw As TreeView)
    '// This routine imports items in the DCB file into the Database
    '// Written By Chris Eastwood
    Dim iFile As Integer
    Dim sFIleName As String
    Dim lCount As Long
    Dim oImport As FileDetails
    Dim sParentKey As String
    Dim sTopParentKey As String
    Dim oColl As Collection
    Dim cHourGlass As CWaitCursor
    Dim lNumCodeItems As Long
    Dim sTmp As String
    Dim intID As Integer
    Dim currKey As String
    Dim intFolderKey As Integer

    Dim oHeader As FileHeader

    ' On Error GoTo vbErrorHandler

    '// Get selected Node
    Set m_nodNode = tvw.SelectedItem
    '// If No Node Selected (very unlikely) then exit
    If m_nodNode Is Nothing Then Exit Sub
    currKey = m_nodNode.Key
    '// Get Import File Name
    sFIleName = frmMain.ShowFileDialog(eOpen, "", "Import Item", "Developers Code Book File|*.dcb")
    '// If no name selected then quit
    If Len(sFIleName) = 0 Then Exit Sub

    '// Get FileHandle
    iFile = FreeFile

    '// Get Top Parent Key
    If m_nodNode.Key = "ROOT" Then
        sTopParentKey = "0"
    Else
        sTopParentKey = Right$(m_nodNode.Key, Len(m_nodNode.Key) - 1)
    End If
    '// Set Cursor to HourGlass
    Set cHourGlass = New CWaitCursor
    cHourGlass.SetCursor
    '// Setup Our Collection Internally
    Set oColl = New Collection

    '// Place all of the Import into a Transaction for Speed & rollback opportunity
    BeginTrans

    '// Open the file
    Open sFIleName For Binary Access Read As iFile

    lCount = 1

    Get #iFile, , oHeader

    '// Now loop through the records in the file
    For lCount = 1 To oHeader.lNumberOfRecords

        '// Get each record until empty
        Get #iFile, , oImport

        If oImport.sName = "" Then Exit For
        If oImport.bFolder Then
            Set m_rs = m_db.OpenRecordset("SELECT * FROM Folders", dbOpenDynaset)
            m_rs.AddNew
            m_rs.Fields("Name").Value = oImport.sName
            If lCount = 1 Then
                intID = 0
                intID = sTopParentKey
                m_rs!ParentID = intID
            End If
            m_rs.Update
            m_rs.Bookmark = m_rs.LastModified
            intFolderKey = m_rs!Id

            oColl.Add Trim$(Str$(intFolderKey)), oImport.sOldID

            m_rs.Close
        Else
            '// Create a new CodeItem for the record
            Set m_rs = m_db.OpenRecordset("SELECT * FROM Code", dbOpenDynaset)
            m_rs.AddNew
            '// Setup the CodeItems values
            m_rs.Fields("Code").AppendChunk oImport.sCode
            m_rs.Fields("Description").Value = oImport.sName
            m_rs.Fields("Example").AppendChunk oImport.sExample
            m_rs.Fields("Notes").AppendChunk oImport.sNotes
            If Not NullString(oImport.sVersion) Then m_rs.Fields("Version").Value = "" & oImport.sVersion
            If Not NullString(oImport.sLevel) Then m_rs.Fields("Level").Value = "" & oImport.sLevel
            '// If this is the first one, then set it's parent to the selected Node database key
            If lCount = 1 Then
                intID = 0
                intID = sTopParentKey
                m_rs!ParentID = intID
            End If

            '// Add it to the collection - indexed by Original Key
            '    oColl.Add oKeys, oKeys.sOldID
            oColl.Add Trim$(Str$(m_rs!Id)), oImport.sOldID
            '        mval = oColl.Item("201")
            '// If we're not on the first item to be imported, restructure the items
            If lCount > 1 Then
                sParentKey = intFolderKey

                If Len(sParentKey) > 0 And sParentKey <> "0" Then
                    'rs!ParentID = oColl.Item(sParentKey) '.sNewID
                    intID = 0
                    'intID = oColl.Item(sParentKey)
                    'm_rs!ParentID = intID
                    m_rs!ParentID = intFolderKey
                    intID = m_rs!Id
                Else
                    m_rs!ParentID = sTopParentKey
                End If
            End If
            sParentKey = ""
            m_rs.Update
            m_rs.Close
        End If
    Next
    '// Close the file
    Close iFile
    '// Commit all of our database work
    CommitTrans
    '// Fill the tree with all records from the database
    FillTree tvw
    '// Now, get the original Node that was the TopParent, and make sure
    '// that it's expanded, and visible
    If Len(sTopParentKey) > 0 And sTopParentKey <> "0" Then
        Set m_nodNode = tvw.Nodes("C" & sTopParentKey)
        Set tvw.SelectedItem = m_nodNode
        m_nodNode.Expanded = True
        m_nodNode.EnsureVisible
    End If

    '// Notify the User of success
    MsgBox "Imported " & lCount - 1 & " Code Items.", vbInformation, App.ProductName

    SelectItem currKey, frmMain.ctlData1

    Exit Sub

vbErrorHandler:
    '// Rollback the database work
    Rollback
    WriteError Err.Number, Err.Description, "ImportCodeItems", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "ImportCodeItems"

End Sub

Public Sub SaveSort(strSort As String, intTabIndex As Integer, lv As ListView)
    Dim blnTab As Boolean
    Dim intPos As Integer
    Dim strType As String
    Dim intID As Integer
    Dim strVersion As String
    Dim strLevel As String
    Dim strValue As String

    On Error Resume Next

    '// Saves the current sort mode
    blnTab = GetSetting(ThisApp, "General", "Remember Tabs", True)
    If blnTab Then
        SaveSetting ThisApp, "General", "Control Panel", intTabIndex
    End If

    strSort = Right$(strSort, Len(strSort) - 8)
    intPos = InStr(1, strSort, ":", vbTextCompare)
    strType = left$(strSort, intPos - 1)

    If lv.ListItems.Count > 0 Then
        m_strKey = lv.ListItems(1).Key
        intID = Right(m_strKey, Len(m_strKey) - 1)

        Set m_rs = m_db.OpenRecordset("SELECT * FROM Code WHERE ID =" & intID, dbOpenSnapshot)

        strVersion = "" & m_rs!Version
        strLevel = "" & m_rs!Level

        m_rs.Close
    End If

    If strType = "Version" Then
        strValue = strVersion
    End If

    If strType = "Level" Then
        strValue = strLevel
    End If

    SaveSetting ThisApp, "General", "Sort Type", strType
    SaveSetting ThisApp, "General", "Sort Value", strValue

End Sub

Public Function FindBranch(tvw As TreeView, sText As String, ctl As ctlFavourites, blnMatch As Boolean) As Boolean

    On Error GoTo vbErrHand

    Dim intID As Integer
    Dim lngRet As Long
    '// Finds an item in the same branch
    '// Currently only searchs one level down
    ctl.ClearFindRes

    m_strKey = tvw.SelectedItem.Key
    If m_strKey = "ROOT" Then
        intID = 0
    Else
        intID = Right(m_strKey, Len(m_strKey) - 1)
    End If

    Set m_rs = m_db.OpenRecordset("SELECT * FROM Code", dbOpenSnapshot)

    If Not EmptyRS(m_rs) Then
        m_rs.MoveFirst
        Do While Not m_rs.EOF
            If m_rs!ParentID = intID Then
                If blnMatch Then '// Match the whole string
                    If m_rs!Description = sText Then 'Found a match
                        ctl.AddFindRes sText, "C" & m_rs!Id
                    End If
                Else
                    lngRet = InStr(1, m_rs!Description, sText, vbTextCompare)
                    If lngRet > 0 Then '// Found a match
                        ctl.AddFindRes m_rs!Description, "C" & m_rs!Id
                    End If
                End If
            End If
            m_rs.MoveNext
        Loop
        m_rs.Close
    End If

    If ctl.ListCount > 0 Then
        ctl.ShowFindTab
        FindBranch = True
    Else
        MsgBox "No Items Found"
        FindBranch = False
    End If
    Exit Function

vbErrHand:
    WriteError Err.Number, Err.Description, "FindBranch", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "FindBranch"
End Function

Public Function FindNotes(sText As String, ctl As Object, tvw As TreeView) As Boolean

    Dim sMessage As String
    Dim lRet As Long
    Dim strID As String
    '// Finds text in the notes section
    On Error GoTo vbErrHand
    FindNotes = False
    ctl.ClearFindRes

    Set m_rs = m_db.OpenRecordset("SELECT Notes, ID FROM Code", dbOpenSnapshot)
    If Not EmptyRS(m_rs) Then
        m_rs.MoveFirst
        Do While Not m_rs.EOF
            lRet = InStr(1, "" & m_rs!Notes, sText, vbTextCompare)
            If lRet <> 0 Then '// We found a match
                strID = "C" & m_rs!Id '// Set the key
                ctl.AddFindRes tvw.Nodes(strID), strID 'Add it to the find results
            End If
            m_rs.MoveNext
        Loop
    End If
    m_rs.Close

    If ctl.ListCount > 0 Then
        sMessage = ctl.ListCount & " item(s) found."
        FindNotes = True
    Else
        sMessage = "No items found."
    End If

    MsgBox sMessage

    ctl.ShowFindTab

    Exit Function

vbErrHand:
    WriteError Err.Number, Err.Description, "FindNotes", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "FindNotes"

End Function

Public Function FindPartX(sFind As String, ctl As ctlFavourites, tvw As TreeView) As Boolean

    Dim sMessage As String
    Dim sRecord As String
    Dim ret As Integer
    Dim strID As String

    On Error GoTo vbErrHand

    ctl.ClearFindRes

    Set m_nodNode = tvw.Nodes("ROOT")

    For Each m_nodNode In tvw.Nodes
        If InStr(UCase$(m_nodNode.Text), UCase$(sFind)) Then
            ctl.AddFindRes m_nodNode.Text, m_nodNode.Key
        End If
        Set m_nodNode = m_nodNode.Next
    Next

    If ctl.ListCount > 0 Then
        sMessage = ctl.ListCount & " item(s) found."
        FindPartX = True
    Else
        sMessage = "No items found."
        FindPartX = False
    End If

    MsgBox sMessage

    ctl.ShowFindTab

    Exit Function

vbErrHand:
    WriteError Err.Number, Err.Description, "FindPartX", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "FindPartX"

End Function

Public Function FindWhole(sText As String, ctl As ctlFavourites, tvw As TreeView) As Boolean
    Dim sMessage As String
    Dim strID As String

    On Error GoTo vbErrHand

    ctl.ClearFindRes

    For Each m_nodNode In tvw.Nodes
        If m_nodNode.Text = sText Then
            strID = m_nodNode.Key
            ctl.AddFindRes sText, strID
        End If
    Next

    If ctl.ListCount > 0 Then
        sMessage = ctl.ListCount & " item(s) found."
        FindWhole = True
    Else
        sMessage = "No items found."
        FindWhole = False
    End If

    MsgBox sMessage

    ctl.ShowFindTab

    Exit Function

vbErrHand:
    WriteError Err.Number, Err.Description, "FindWhole", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "FindWhole"

End Function

Private Function NullString(strText As String) As Boolean
    NullString = False
    If strText = "" Then NullString = True
    If strText = vbNullString Then NullString = True
End Function

Private Sub HighlightFolders(tvw As TreeView, strKey As String)
    Dim TVI As TVITEM
    Dim lngHwnd As Long
    Dim lngItem As Long
    Dim lngRet As Long
    '// Makes a node bold
    If tvw.Nodes(strKey) Is Nothing Then Exit Sub
    '// Set the selected item
    Set tvw.SelectedItem = tvw.Nodes(strKey)
    '// Get the window handle
    lngHwnd = tvw.hwnd
    lngItem = SendMessage(tvw.hwnd, TVM_GETNEXTITEM, TVGN_CARET, 0&)
    If lngItem <> 0 Then
        With TVI
            .hItem = lngItem
            .mask = TVIF_STATE
            .stateMask = TVIS_BOLD
            lngRet = SendMessageAny(tvw.hwnd, TVM_GETITEM, 0&, TVI)
            .State = TVIS_BOLD
        End With
        '// Apply the new style
        lngRet = SendMessageAny(tvw.hwnd, TVM_SETITEM, 0&, TVI)
    End If
End Sub

Public Property Get DBName() As String
    DBName = m_strDBName
End Property

Public Property Let DBName(ByVal NewName As String)
    m_strDBName = NewName
End Property

Public Sub UpdateKey()

    Dim intKey As Integer
    Dim intParentKey As Integer

    If m_strParentKey = "ROOT" Then
        intParentKey = "0"
    Else
        intParentKey = m_strParentKey
    End If

    intKey = m_strKey

    Set m_rs = m_db.OpenRecordset("SELECT * FROM Code WHERE ID =" & intKey, dbOpenDynaset)
    m_rs.Edit
    m_rs!ParentID = intParentKey
    m_rs.Update
    m_rs.Close

End Sub

Public Property Let ParentKey(ByVal NewKey As String)
    m_strParentKey = NewKey
End Property

'Public Sub ReWrite(ctl As Object)
'Set m_rs = m_db.OpenRecordset("SELECT * FROM Code")
'
'    m_rs.MoveFirst
'    Do While Not m_rs.EOF
'        frmMain.ctlData1.code = "" & m_rs!code
'        m_rs.Edit
'        m_rs!code = "" & ctl.PlainCode
'        m_rs.Update
'        m_rs.MoveNext
'    Loop
'    m_rs.Close
'
'
'End Sub

Public Sub AddFolder(tvw As TreeView, ctl As ctlData)
    ' Adds a new folder to the db and tree
    Dim intID As Integer

    On Error GoTo vbErrHand

    If tvw.SelectedItem Is Nothing Then Exit Sub

    If tvw.SelectedItem.Key = "ROOT" Then
        m_strParentKey = "0"
    Else
        m_strParentKey = Right$(tvw.SelectedItem.Key, Len(tvw.SelectedItem.Key) - 1)
    End If

    Set m_rs = m_db.OpenRecordset("SELECT * FROM Folders")

    With m_rs
        .AddNew
        .Fields("Name").Value = "New Folder"
        .Fields("ParentID").Value = m_strParentKey
        .Update
        .Bookmark = .LastModified
        intID = .Fields("ID").Value
        .Close
    End With

    With tvw
        .Nodes.Add tvw.SelectedItem, tvwChild, "F" & intID, "New Folder", "CLOSED"
        .Nodes("F" & intID).EnsureVisible
        .SelectedItem = .Nodes("F" & intID)
    End With

    m_strDesc = "New Folder"
    m_strKey = "F" & intID

    SelectItem "F" & intID, ctl

    ctl.CountItems tvw

    tvw.StartLabelEdit

    Exit Sub

vbErrHand:
    WriteError Err.Number, Err.Description, "AddFolder", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "AddFolder"
End Sub

Public Function GetVersion() As Long
    Dim rs As Recordset
    ' We use a seperate rs var incase it is in use
    Set rs = m_db.OpenRecordset("SELECT * FROM Version")
    If Not EmptyRS(rs) Then
        rs.MoveFirst
        GetVersion = rs.Fields("DB Version").Value
    End If
    rs.Close
    Set rs = Nothing
End Function

Public Sub InserObject(blnFile As Boolean, Optional strPath As String, Optional strLink As String)
    Dim cHourGlass As CWaitCursor

    Set cHourGlass = New CWaitCursor
    cHourGlass.SetCursor

    If blnFile Then
        Set m_rs = m_db.OpenRecordset("SELECT * FROM Files")

        With m_rs
            .AddNew
            .Fields("CodeID").Value = Right$(m_strKey, Len(m_strKey) - 1)
            .Fields("Name").Value = m_strDesc

            BuildRSFile m_rs, strPath

            .Fields("DateTime").Value = m_strDate
            .Update
            .Bookmark = .LastModified
            m_strKey = "O" & .Fields("ID")
            .Close
        End With

        DBEngine.Idle dbRefreshCache
    Else
        ' Insert a link
        Set m_rs = m_db.OpenRecordset("SELECT * FROM Links")

        With m_rs
            .AddNew
            .Fields("Link").Value = strLink
            .Fields("Name").Value = m_strDesc
            .Fields("DateTime") = Now
            .Update
            .Bookmark = .LastModified
            m_strKey = "L" & .Fields("ID")
            .Close
        End With
    End If
End Sub

Private Sub BuildRSFile(rs As Recordset, strPath As String)
    ' Author: Chris Eastwood - [e-mail]
    Dim lLen As Long
    Dim lCount As Long
    Dim lFragment As Long
    Dim lChunks As Long
    Dim bChunk() As Byte
    Dim iFileNum As Integer
    Dim oField As Field
    '
    ' Copy the File into the recordset field
    '
    On Error GoTo vbErrorHandler

    iFileNum = FreeFile
    '
    ' Open the file for binary access so we can read it in chunks
    '
    Open strPath For Binary Access Read As iFileNum
    '
    ' Get Original Date/Time of the File for storing in the Database
    '
    m_strDate = Now

    lLen = LOF(iFileNum)
    '
    ' Get the number of chunks
    '
    lChunks = lLen \ CHUNKSIZE
    '
    ' Get the small fragment size
    '
    lFragment = lLen Mod CHUNKSIZE

    ReDim bChunk(lFragment)

    Get iFileNum, , bChunk
    Set oField = m_rs("File")

    oField.Value = ""
    '
    ' Append the first chunk
    '
    oField.AppendChunk bChunk

    ReDim bChunk(CHUNKSIZE)
    '
    ' Now read in the rest of the file into the field
    '
    For lCount = 1 To lChunks
        Get iFileNum, , bChunk()
        oField.AppendChunk bChunk
    Next
    '
    ' Close the file
    '
    Close iFileNum

    Exit Sub

vbErrorHandler:
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub

Public Sub EditLink(strID As String, blnDel As Boolean, lv As ListView, Optional strNewLink As String, Optional strNewName As String)
    ' Edits or removes a link

    Dim intID As Integer

    ' Retrieve the link's ID
    intID = Right$(strID, Len(strID) - 1)

    ' Select the record
    Set m_rs = m_db.OpenRecordset("SELECT * FROM Links WHERE ID =" & intID)

    ' Check if we need to delete the item
    If blnDel Then

        With m_rs
            .Delete
            .Close
        End With

        lv.ListItems.Remove strID

    Else

        With m_rs
            .Edit
            .Fields("Name").Value = strNewName
            .Fields("Link").Value = strNewLink
            .Update
            .Close
        End With

        lv.ListItems(strID).Text = strNewName
        lv.ListItems(strID).SubItems(1) = strNewLink

    End If

End Sub

Public Sub GetLinks(lv As ListView)
On Error GoTo vbErrHand

    Set m_rs = m_db.OpenRecordset("SELECT * FROM Links")

    If Not EmptyRS(m_rs) Then
        m_rs.MoveFirst

        Do While Not m_rs.EOF

            Set m_liItem = lv.ListItems.Add(, "L" & m_rs!Id, m_rs!Name)
            m_liItem.SubItems(1) = m_rs!Link

            m_rs.MoveNext
        Loop

        m_rs.Close
    End If

    Exit Sub

vbErrHand:
    WriteError Err.Number, Err.Description, "GetLinks", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "GetLinks"

End Sub

Public Sub GetFiles(lv As ListView)
    Dim strExt As String

    On Error GoTo vbErrHand

    Set m_rs = m_db.OpenRecordset("SELECT * FROM Files")

    If Not EmptyRS(m_rs) Then
        m_rs.MoveFirst

        Do While Not m_rs.EOF

            strExt = Right$(m_rs!Name, 3)
            Set m_liItem = lv.ListItems.Add(, "O" & m_rs!Id, strExt)
            m_liItem.SubItems(1) = m_rs!Name

            m_rs.MoveNext
        Loop

        m_rs.Close
    End If

    Exit Sub

vbErrHand:
    WriteError Err.Number, Err.Description, "GetFiles", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "GetFiles"


End Sub

Public Sub DeleteFile(lv As ListView)
    Dim intID As Integer

    intID = Right$(m_strKey, Len(m_strKey) - 1)

    Set m_rs = m_db.OpenRecordset("SELECT * FROM Files WHERE ID =" & intID)

    With m_rs
        .Delete
        .Close
    End With

    lv.ListItems.Remove m_strKey
End Sub

Public Sub ExportToFile(ByVal strFileName As String)
    '
' Export the file from the database to the passed filename
' Written by Chris Eastwood - [e-mail]
'
    Dim iFileNum As Integer
    Dim lFileLen As Long
    Dim lChunks As Long
    Dim lFragment As Long
    Dim bChunk() As Byte
    Dim lCount As Long
    Dim oField As Field
    Dim cHourGlass As CWaitCursor

' Get the field from the database

    Set m_rs = m_db.OpenRecordset("SELECT * FROM Files WHERE ID =" & Right$(m_strKey, Len(m_strKey) - 1))

    If EmptyRS(m_rs) Then Exit Sub

' Set the cursor

    Set cHourGlass = New CWaitCursor
    cHourGlass.SetCursor

    iFileNum = FreeFile

' Created the named file

    Open strFileName For Binary Access Write As iFileNum
    Set oField = m_rs.Fields("File")

' Get the length of the file and the number of chunks required

    lFileLen = oField.FieldSize
    lChunks = lFileLen \ CHUNKSIZE
    lFragment = lFileLen Mod CHUNKSIZE

' Write away the chunks to the file

    For lCount = 1 To lChunks
        ReDim bChunk(CHUNKSIZE)
        bChunk() = oField.GetChunk(((lCount - 1) * CHUNKSIZE), CHUNKSIZE)
        Put iFileNum, , bChunk()
    Next

' Write the final (or first if lChunks = 0) chunk

    ReDim bChunk(lFragment)
    bChunk = oField.GetChunk(lChunks * CHUNKSIZE, lFragment)

    Put iFileNum, , bChunk()
    Close iFileNum

    m_rs.Close

' Tell the user that we have finished

    MsgBox "Exported file to " & strFileName
End Sub